home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
MacTech 1 to 12
/
MacTech-vol-1-12.toast
/
Tools
/
Alpha 6.51b13 ƒ
/
Tcl
/
Modes
/
htmlUtils.tcl
< prev
next >
Wrap
Text File
|
1997-03-04
|
87KB
|
2,684 lines
#===============================================================================
#
# htmlUtils.tcl (called from html.tcl)
#
# Part of HTML mode 1.4.1
#
# HTML Utilities
#
# Copyright 1996, 1997 by Johan Linde <jl@theophys.kth.se>.
# This software may be used freely, and distributed freely, as long as
# the receiver is not obligated in any way by receiving it.
#
# If you make improvements to this file, please share them!
#
#===============================================================================
#
# Mark file
#
proc parseFuncsHTML {} {
return [htmlMarkFile2 0]
}
proc HTMLMarkFile {} {
htmlMarkFile2 1
message "Marks set."
}
proc htmlMarkFile2 {markfile} {
set pos 0
set exp {<[Hh][1-6][^>]*>}
set exp2 {</[Hh][1-6]>}
while {![catch {search -s -f 1 -r 1 -m 0 -i 0 $exp $pos} rs] &&
![catch {search -s -f 1 -r 1 -m 0 -i 0 $exp2 [lindex $rs 1]} res]} {
set start [lindex $rs 0]
set end [lindex $res 1]
set text [getText $start $end]
# Remove tabs and returns from text.
regsub -all "\[\t\r\]+" $text " " text
set headtext ""
# remove all tags from text
while {1} {
set lt [string first < $text ]
if {$lt < 0} { break }
if {$lt > 0} { append headtext [string range $text 0 [expr $lt - 1]] }
set text [string range $text $lt end]
set gt [string first > $text]
if {$gt < 0} { break }
set text [string range $text [expr $gt + 1] end]
}
# Set mark only on one line.
if {$end > [nextLineStart $start]} {
set end [expr [nextLineStart $start] - 1]
}
set indlevel [getText [expr $start + 2] [expr $start + 3]]
if {$indlevel > 0 && $indlevel < 7} {
set lab [string range " " 2 $indlevel]
append lab $lab $indlevel " " $headtext
# Cut the menu item if it's longer than 30 letters, not to make it too long.
if {[string length $lab] > 30} {
set lab "[string range $lab 0 29]…"
}
if {$markfile} {
setNamedMark $lab $start $start $end
} else {
lappend parse $lab [lineStart $start]
}
}
set pos $end
}
if {!$markfile} {return $parse}
}
# Opens a file in the home page folder, if clicked on a link to a text file.
# If the file doesn't exist, it can be opened in a new empty window, and automatically
# saved in the right place.
proc HTMLDblClick {from to} {
global htmlURLAttr HTMLmodeVars filepats
# Build regular expressions with URL attrs.
set exp "("
foreach attr $htmlURLAttr {
append exp "$attr|"
}
set exp [string trimright $exp |]
# append exp ")\"?(\[^ \\t\\r\\n\">\]+)\"?"
append exp ")(\"\[^\">\]+\"|\[^ \\t\\n\\r>\]+)"
# Check if user clicked on a link.
if {![catch {search -s -f 0 -r 1 -i 1 -m 0 $exp $from} res] && [lindex $res 1] > $from} {
# Get path to this window.
if {![string length [set thisURL [htmlThisFilePath 1]]]} {return}
# Get path to link.
regexp -nocase $exp [getText [lindex $res 0] [lindex $res 1]] dum1 dum2 linkTo
set linkTo [htmlURLunEscape [string trim $linkTo \"]]
# Anchors points to file itself if no BASE. (BASE if [llength $thisURL] > 4)
if {[string index $linkTo 0] == "#" && [llength $thisURL] > 4} {return}
if {[catch {lindex [htmlPathToFile [lindex $thisURL 0] [lindex $thisURL 1] [lindex $thisURL 2] [lindex $thisURL 3] $linkTo] 0} linkToPath]} {
if {$linkToPath == ""} {
message "Link not well-defined."
} else {
message "Link points to $linkToPath. Doesn't map to a file on the disk."
}
return
}
# Does the file exist?
if {[file exists $linkToPath] && ![file isdirectory $linkToPath]} {
# Is it a text file?
if {[htmlIsTextFile $linkToPath message]} {
edit -c $linkToPath
}
} else {
set isAnHtmlFile 0
foreach suffix $filepats(HTML) {
if {[string match $suffix $linkToPath]} {set isAnHtmlFile 1}
}
if {(![file exists $linkToPath] && !$isAnHtmlFile) || [file isdirectory $linkToPath] ||
![regexp {[^:]+} $linkToPath disk] || ![file exists $disk:]} {
message "Cannot open [file tail $linkToPath]."
} else {
set htmlFile [file tail $linkToPath]
if {[lindex [dialog -w 350 -h 140 -t "The file '$htmlFile' does not exist.\
Do you want to open a new empty window with this name?\
It will automatically be saved in the right place,\
and if necessary, new folders will be created." 10 10 340 100 \
-b Yes 20 110 85 130 -b No 115 110 180 130] 1]} {return}
# Create a new file and open it.
foreach p [split [file dirname $linkToPath] :] {
append path "$p:"
# make new folders if needed.
if {![file exists $path]} {
mkdir $path
} elseif {![file isdirectory $path]} {
alertnote "Cannot make a new folder '[file tail $path]'.\
There is already a file with the same name."
return
}
}
append path "$htmlFile"
# create an empty file.
set fid [open $path w]
# I suppose it's best to close it, too.
close $fid
edit $path
}
}
} elseif {![catch {search -s -f 0 -r 1 -i 1 -m 0 {FILE=\"[^\"]+\"} $from} res] && [lindex $res 1] > $from} {
regexp -nocase {FILE=\"([^\"]+)\"} [getText [lindex $res 0] [lindex $res 1]] dum fil
set fil [htmlUnQuote $fil]
if {[file exists $fil]} {
edit -c $fil
} else {
message "File not found."
}
} elseif {![htmlRevealColor 1]} {
message "You must click on a URL, include tag, or a color."
}
}
#
# return positions of tags of including elements, as a list of 5 elements --
# openstart openend closestart closeend elementname.
# Elements without a closing tag are ignored.
# args: point to start search backward from; point which must be enclosed
#
# if any problem, return just {0}
#
proc htmlGetContainer {curPos inclPos} {
set startPos $curPos
set startPos2 $inclPos
set searchFinished 0
message "Searching for enclosing tags…"
while {!$searchFinished} {
# find first tag
set isStartTag 0
while {!$isStartTag} {
if {[catch {search -s -f 0 -r 1 -i 0 -m 0 {<[^<>]+>} $startPos} res]} {
message ""
return {0}
}
set tag1start [lindex $res 0]
set tag1end [lindex $res 1]
# get element name
if {![regexp {<([^ \t\r]+).*>} [getText $tag1start $tag1end] tmp tag]} {
message ""
return {0}
}
# is this a closing tag?
if {[string index $tag 0] != "/"} { set isStartTag 1}
set startPos [expr $tag1start - 1]
}
# find closing tag
set res [htmlGetClosing $tag $tag1end]
set tag2start [lindex $res 0]
set tag2end [lindex $res 1]
# If container enclosed along with us, or there is no closing tag,
# continue searching.
if {![llength $res] || $tag2end < $inclPos} {
set startPos [expr $tag1start - 1]
} else {
set Container "$tag1start $tag1end $tag2start $tag2end"
set searchFinished 1
}
}
message ""
return [concat $Container [string toupper $tag]]
}
#
# return position an opening tag if the first element to the left
# of startPos is an element with only an opening tag, as a list of 3 elements --
# openstart openend elementname.
#
# if any problem, return empty string
#
proc htmlGetOpening {startPos} {
while {1} {
if {[catch {search -s -f 0 -r 1 -i 0 -m 0 {<[^<>]+>} $startPos} res]} {
return
}
set tag1start [lindex $res 0]
set tag1end [lindex $res 1]
# get element name
if {![regexp {<([^ \t\r]+).*>} [getText $tag1start $tag1end] tmp tag]} {
return
}
# is this a closing tag?
if {[string index $tag 0] == "/"} {return}
# comment?
if {[string range $tag 0 2] != "!--"} {break}
set startPos [expr $tag1start - 1]
}
# find closing tag
set res [htmlGetClosing $tag $tag1end]
if {![llength $res] } {
return "$tag1start $tag1end [string toupper $tag]"
} else {
return
}
}
proc htmlGetClosing {tag sPos} {
set x </${tag}>
set sPos2 $sPos
while {1} {
set res [search -s -f 1 -r 1 -i 1 -m 0 -n $x $sPos]
# Found any closing tag.
if {![llength $res]} {break}
# Look for another opening tag of the same element.
set y "<${tag}(\[ \\t\\r\]+|>)"
set res2 [search -s -f 1 -r 1 -i 1 -m 0 -n $y $sPos2]
# Is it further away than the closing tag.
if {![llength $res2] || [lindex $res2 0] > [lindex $res 0]} {break}
# If not, find the next closing tag.
set sPos [lindex $res 1]
set sPos2 [lindex $res2 1]
}
return $res
}
# Change choice of an attribute with pre-defined choices.
proc htmlChangeChoice {} {
set pos [expr [getPos] - 1]
if {[catch {search -s -f 0 -r 1 -i 0 -m 0 {<[^<>]+>} $pos} res] ||
[lindex $res 1] < $pos ||
![regexp {<([^ \t\r>]+)} [getText [lindex $res 0] [lindex $res 1]] tmp tag] ||
[catch {search -s -f 0 -r 1 -i 0 -m 0 {[ \t\r]+[^=]+=\"?[^\" \t\r>]+\"?} $pos} res1] ||
[lindex $res1 1] < $pos ||
![regexp {([^=]+=)(([^\" \t\r>]+)|(\"[^\" \t\r]+\"))} [getText [lindex $res1 0] [lindex $res1 1]] tmp attr choice]} {
beep
message "Current position is not at an attribute with choices."
return
}
set pos0 [expr [lindex $res1 0] + [string length $attr]]
set pos1 [expr $pos0 + [string length $choice]]
set choice [string trim $choice \"]
set tag [string toupper $tag]
if {$tag == "INPUT"} {
if {![regexp -nocase {type=(([^\" \t\r>]+)|(\"[^\" \t\r]+\"))} [getText [lindex $res 0] [lindex $res 1]] tmp tag]} {
beep
message "Current position is not at an attribute with choices."
return
}
set tag [string trim [string toupper $tag] \"]
}
if {$tag == "LI"} {
set ltype [htmlFindList]
if {$ltype == "UL"} {
set tag "LI IN UL"
} elseif {$ltype == "OL"} {
set tag "LI IN OL"
}
}
set attr [string trim [string toupper $attr]]
if {($tag != "OL" && $tag != "LI IN OL") || $attr != "TYPE="} {set choice [string toupper $choice]}
set choices [htmlGetChoices $tag]
foreach c $choices {
if {[string match "${attr}*" $c]} {
lappend matches [string range $c [string length $attr] end]
}
}
if {![info exists matches]} {
beep
message "Current position is not at an attribute with choices."
return
}
if {[set this [lsearch -exact $matches $choice]] < 0} {set this 0}
incr this
if {$this == [llength $matches]} {set this 0}
set this [lindex $matches $this]
if {($tag != "OL" && $tag != "LI IN OL") || $attr != "TYPE="} {set this [htmlSetCase $this]}
replaceText $pos0 $pos1 "\"$this\""
}
# Asks for a file and returns the file name including the relative path from
# current window, provided both are in the home page folder. Otherwise an empty
# string is returned.
proc htmlGetFile {} {
# get path to this window.
if {![string length [set this [htmlThisFilePath 0]]]} {return}
# Get the file to link to.
if {[catch {getfile "Select file to link to."} linkFile]} {
return
}
# Get URL for this file?
set link [htmlBASEfromPath $linkFile]
if {[lindex $link 4] == "4"} {
alertnote "You can't link to a file in an include folder."
return
}
if {[lindex $this 0] == [lindex $link 0]} {
set linkTo [htmlRelativePath "[lindex $this 1][lindex $this 2]" "[lindex $link 1][lindex $link 2]"]
} else {
set linkTo [join [lrange $link 0 2] ""]
}
getFileInfo $linkFile arr
if {$arr(type) == "GIFf"} {
set widthheight [htmlGIFWidthHeight $linkFile]
} elseif {$arr(type) =="JPEG" || $arr(type) == "JFIF"} {
set widthheight [htmlJPEGWidthHeight $linkFile]
} else {
set widthheight ""
}
# Add URL to cache.
htmlAddToCache URLs $linkTo
return [list $linkTo $widthheight]
}
# Check that links are valid.
proc htmlCheckLinks {where} {
global HTMLmodeVars
# Save all open window?
if {$where != "Window" &&
[htmlAllSaved "-c {Save all open windows before checking links?}"] == "cancel"} { return}
set filebase 0
if {$where == "File"} {
if {[catch {getfile "Select file to scan."} files]} {return}
# Is this a text file?
if {![htmlIsTextFile $files alertnote]} {return}
set base [htmlBASEfromPath $files]
if {$HTMLmodeVars(useBigBrother)} {htmlBigBrother "$files"; return}
set path [lindex $base 1]
set homepage [lindex $base 3]
set isinfld [lindex $base [expr 3 + [lindex $base 4] / 2]]
set base [lindex $base 0]
if {$base == "file:///"} {set filebase [string length "[file dirname $files]:"]}
# Make it a list in case it contains spaces.
set files [list $files]
} elseif {$where == "Window"} {
set files [stripNameCount [lindex [winNames -f] 0]]
if {![file exists $files]} {
if {[lindex [dialog -w 200 -h 70 -t "You must save the window." 10 10 390 30 \
-b Save 20 40 85 60 \
-b Cancel 110 40 175 60] 1]} {
return
}
if {![catch {saveAs "Untitled.html"}]} {
set files [stripNameCount [lindex [winNames -f] 0]]
} else {
return
}
} else {
if {[winDirty] && [askyesno "Save window?"] == "yes"} {save}
}
set base [htmlBASEfromPath $files]
if {$HTMLmodeVars(useBigBrother)} {htmlBigBrother "$files"; return}
set path [lindex $base 1]
set homepage [lindex $base 3]
set isinfld [lindex $base [expr 3 + [lindex $base 4] / 2]]
set base [lindex $base 0]
if {$base == "file:///"} {set filebase [string length "[file dirname $files]:"]}
set files [list $files]
} elseif {$where == "Folder"} {
if {[catch {htmlGetDir "Folder to scan."} folder]} {return}
set base [htmlBASEfromPath $folder]
set subFolders [expr ![string compare yes [askyesno "Check files in subfolders?"]]]
if {$subFolders && ![set subFolders [expr ![htmlContainHpFolder $folder]]] &&
[lindex [dialog -w 410 -h 135 -t "The folder '[file tail $folder]' contains a\
home page folder or an include folder, but is itself not inside one. You can't\
simultaneously check links both inside and outside home page or include folders.\
Sorry!\rBut\
you can still check this folder and skip the subfolders." 10 10 400 90\
-b Check 20 105 85 125 -b Cancel 110 105 175 125] 1]} {return}
if {$HTMLmodeVars(useBigBrother)} {htmlBigBrother "$folder:" $subFolders; return}
set path [lindex $base 1]
set homepage [lindex $base 3]
set isinfld [lindex $base [expr 3 + [lindex $base 4] / 2]]
set base [lindex $base 0]
if {$base == "file:///"} {set filebase [string length "$folder:"]}
if {$subFolders} {
set files [htmlAllHTMLfiles $folder]
} else {
set files [htmlGetHTMLfiles $folder]
}
} else {
# Check that a home page is defined.
if {![htmlIsThereAHomePage]} {return}
if {[catch {htmlWhichHomePage "check links in"} hp]} {return}
set homepage [lindex $hp 0]
set isinfld $homepage
if {$HTMLmodeVars(useBigBrother)} {htmlBigBrother "$homepage:" 1; return}
set files [htmlAllHTMLfiles $homepage]
set base [lindex $hp 1]
set path [lindex $hp 2]
}
htmlScanFiles $files $base $path $homepage $isinfld 1 $filebase
}
proc htmlBigBrother {path {searchSubFolder 0}} {
global HTMLmodeVars
# define url mapping
set urlmap [htmlURLmap]
# launches Big Brother
if {[catch {file tail [launchBackAppl Bbth]} name]} {
alertnote "Could not find or launch Big Brother."
return
}
# Read all settings.
set allSettings [AEBuild -r $name core getd ---- "obj{want:type('reco'),from:null(),form:'prop',seld:type('allS')}"]
set allSettings [string range $allSettings 17 [expr [string length $allSettings] - 2]]
if {[regexp {mapS:} $allSettings]} {
# Change settings
if {!$HTMLmodeVars(useBBoptions)} {
AEBuild $name core setd "----" "obj{want:type('bool'),from:null(),form:'prop',seld:type('Loly')}" "data" "bool(«0$HTMLmodeVars(ignoreRemote)»)"
AEBuild $name core setd "----" "obj{want:type('bool'),from:null(),form:'prop',seld:type('Roly')}" "data" "bool(«0$HTMLmodeVars(ignoreLocal)»)"
}
AEBuild $name core setd "----" "obj{want:type('bool'),from:null(),form:'prop',seld:type('Sfld')}" "data" "bool(«0$searchSubFolder»)"
AEBuild $name core setd "----" "obj{want:type('mapG'),from:null(),form:'prop',seld:type('mapS')}" "data" "\[$urlmap\]"
} else {
alertnote "Cannot change the settings in Big Brother. You need Big Brother 1.1 or later."
}
# Sends a file or folder to be opened.
sendOpenEvent noReply $name $path
if {[regexp {mapS:} $allSettings]} {
# Restore the settings.
AEBuild $name core setd "----" "obj{want:type('reco'),from:null(),form:'prop',seld:type('allS')}" "data" $allSettings
}
if {$HTMLmodeVars(checkInFront)} {switchTo $name}
}
# Moves files from one folder to another and update all links to the moved files
# as well as all links in the moved files.
proc htmlMoveFiles {} {
global HTMLmodeVars
# Check that a home page is defined.
if {![htmlIsThereAHomePage]} {return}
if {[htmlAllSaved "{All windows must be saved before you can moves files. Save?}"] == "no"} {return}
# Get folder to move from.
if {[catch {htmlGetDir "Move from."} fromFolder]} {return}
set base [htmlBASEfromPath $fromFolder]
# Is this folder in a home page folder?
if {[lindex $base 0] == "file:///"} {
alertnote "'[file tail $fromFolder]' is not in a home page folder or an include folder."
return
}
set fromPath [lindex $base 1]
set homepage [lindex $base 3]
set fromBase [lindex $base 0]
set isInInclFldr [lindex $base 4]
set inclFld [lindex $base 5]
# Check that the corresponding include or home page folder exists.
if {$isInInclFldr} {
if {![file isdirectory $homepage]} {
alertnote "Could not find the corresponding home page folder for\
${fromBase}$fromPath. Fix that and try again."
htmlHomePages "${fromBase}$fromPath"
return
}
} elseif {$inclFld != "" && ![file isdirectory $inclFld]} {
alertnote "Could not find the corresponding include folder for\
${fromBase}$fromPath. Fix that and try again."
htmlHomePages "${fromBase}$fromPath"
return
}
# Get files to move.
set files [glob -nocomplain "$fromFolder:*"]
foreach f $files {
if {![file isdirectory $f]} {
lappend filelist [file tail $f]
}
}
if {![info exists filelist]} {
alertnote "Empty folder."
return
}
if {[catch {listpick -p "Select files to move." -l $filelist} movefiles] || \
![string length $movefiles]} {return}
# Get folder to move to.
if {[catch {htmlGetDir "Move to."} toFolder]} {return}
if {$fromFolder == $toFolder} {
alertnote "This is the same folder as you moved from."
return
}
# Is this folder in the same home page folder?
if {!$isInInclFldr && ![string match "${homepage}:*" "$toFolder:"] ||
$isInInclFldr && ![string match "${inclFld}:*" "$toFolder:"]} {
set msg {"home page" "" "" "" "include"}
alertnote "'[file tail $toFolder]' is not in the same [lindex $msg $isInInclFldr] folder."
return
}
# Move the files.
foreach f $movefiles {
if {[file exists "$toFolder:$f"]} {
if {[askyesno "Replace '$f' in folder '[file tail $toFolder]'?"] == "yes"} {
removeFile "$toFolder:$f"
} else {
continue
}
}
set reo 0
foreach w [winNames -f] {
if {[stripNameCount $w] == "$fromFolder:$f"} {
alertnote "'[file tail $w]' must be closed before it can be moved. It will be reopened again."
bringToFront $w
killWindow
set reo 1
}
}
if {[catch {mv "$fromFolder:$f" "$toFolder:$f"}] && ![file exists "$toFolder:$f"]} {
alertnote "Could not move $f. An error occured."
if {$reo} {lappend reOpen "$fromFolder:$f"}
} else {
lappend movedFiles "$fromFolder:$f"
lappend movedFiles2 "$toFolder:$f"
if {$reo} {lappend reOpen "$toFolder:$f"}
}
}
if {[info exists movedFiles] && $isInInclFldr} {
if {[lindex [dialog -w 400 -h 70 -t "Files have been moved. Update links?" \
10 10 290 30 -b Update 20 40 85 60 -b Cancel 105 40 170 60] 0]} {
set changed ""
set num [htmlUpdateAfterMove2 $movedFiles $movedFiles2 $fromBase $fromPath $inclFld]
set x [htmlUpdateAfterMove3 $movedFiles $movedFiles2 $homepage]
incr num [lindex $x 0]
set changed [concat $changed [lindex $x 1]]
}
} elseif {[info exists movedFiles]} {
set box " -t {Files have been moved. Update links?} 10 10 390 30"
if {$inclFld != ""} {
append box " -r {Update both home page folder and include folder} 1 10 40 390 55 \
-r {Update only home page folder} 0 10 60 390 75 -r {Update only include folder} 0 10 80 390 95"
set he 140
} else {
set he 70
}
append box " -b Update 20 [expr $he - 30] 85 [expr $he - 10] -b Cancel 105 [expr $he - 30] 170 [expr $he - 10]"
set values [eval [concat dialog -w 400 -h $he $box]]
if {$inclFld != "" && ([lindex $values 0] || [lindex $values 1]) && [lindex $values 3] ||
$inclFld == "" && [lindex $values 0]} {
set x [htmlUpdateAfterMove $movedFiles $movedFiles2 $fromBase $fromPath $homepage $homepage]
set num [lindex $x 0]
set changed [lindex $x 1]
incr num [htmlUpdateAfterMove2 $movedFiles $movedFiles2 $fromBase $fromPath $homepage]
}
if {$inclFld != "" && ([lindex $values 0] || [lindex $values 2]) && [lindex $values 3]} {
set x [htmlUpdateAfterMove $movedFiles $movedFiles2 $fromBase $fromPath $homepage $inclFld]
incr num [lindex $x 0]
set changed [concat $changed [lindex $x 1]]
}
}
catch {message "$num files has been modified including the ones moved."}
if {[info exists reOpen] && [askyesno "Reopen previously closed windows?"] == "yes"} {
foreach r $reOpen {
edit $r
}
}
if {[llength $changed] && [askyesno "Update affected windows?"] == "yes"} {
foreach r $changed {
bringToFront $r
revert
}
}
}
# Updates links to moved files.
proc htmlUpdateAfterMove {movedFiles movedFiles2 fromBase fromPath homepage isinfld} {
global htmlURLAttr
set allfiles [htmlAllHTMLfiles $isinfld]
foreach f $movedFiles2 {
if {[set i [lsearch -exact $allfiles $f]] >= 0} {
set allfiles [lreplace $allfiles $i $i]
}
}
# Build regular expressions with URL attrs.
set exp "("
foreach attr $htmlURLAttr {
append exp "$attr|"
}
set exp [string trimright $exp |]
append exp ")"
# set exprr "$exp\"?(\[^ \\t\\n\\r\">\]+)\"?"
set exprr "${exp}(\"\[^\">\]+\"|\[^ \\t\\n\\r>\]+)"
# Update links to the moved files.
set toModify [htmlScanFiles $allfiles $fromBase $fromPath $homepage $isinfld 0 0 $movedFiles]
set num 0
set changed ""
if {[llength $toModify]} {
set thisfile ""
foreach modify $toModify {
set fil [lindex $modify 0]
if {$thisfile != $fil} {
if {[string length $thisfile]} {
if {[catch {open $thisfile w} fid]} {
alertnote "Could not update [file tail $thisfile]. An error occured."
} else {
puts -nonewline $fid [join $filecont "\r"]
close $fid
}
}
message "Modifying [file tail $fil]…"
foreach w [winNames -f] {
if {[stripNameCount $w] == "$fil"} {
lappend changed $w
}
}
set fid [open $fil r]
incr num
set filec [read $fid]
close $fid
if {[regexp {\n} $filec]} {
set newln "\n"
} else {
set newln "\r"
}
set filec [split $filec $newln]
set filecont ""
foreach fc $filec {
lappend filecont [string trimleft $fc "\r"]
}
}
set thisfile $fil
set linenum [expr [lindex $modify 1] - 1]
set line [lindex $filecont $linenum]
set path [lindex $movedFiles2 [lsearch -exact $movedFiles [lindex $modify 5]]]
set lnk [htmlBASEfromPath $path]
if {[lindex $modify 2] == [lindex $lnk 0]} {
set linkTo [htmlRelativePath "[lindex $modify 3][lindex $modify 4]" "[lindex $lnk 1][lindex $lnk 2]"]
} else {
set linkTo [join [lrange $lnk 0 2] ""]
}
set linkTo [htmlURLescape2 $linkTo]
regexp -indices [lindex $modify 6] $line href
regexp -nocase -indices $exprr [string range $line [lindex $href 0] [lindex $href 1]] a b url
set anchor ""
regexp {[^#]*(#[^\"]*)} [lindex $modify 6] a anchor
set line "[string range $line 0 [expr [lindex $href 0] + [lindex $url 0] - 1]]\"$linkTo$anchor\"[string range $line [expr [lindex $href 0] + [lindex $url 1] + 1] end]"
set filecont [lreplace $filecont $linenum $linenum $line]
}
if {[catch {open $thisfile w} fid]} {
alertnote "Could not update [file tail $thisfile]. An error occured."
} else {
puts -nonewline $fid [join $filecont "\r"]
close $fid
}
}
return [list $num $changed]
}
# Updates links in moved files.
proc htmlUpdateAfterMove2 {movedFiles movedFiles2 fromBase fromPath homepage} {
global htmlURLAttr
set expBase "<(base\[ \\t\\n\\r\]+)\[^>\]*>"
set expBase2 "(href=)\"?(\[^ \\t\\n\\r\">\]+)\"?"
# Build regular expressions with URL attrs.
set exp "("
foreach attr $htmlURLAttr {
append exp "$attr|"
}
set exp [string trimright $exp |]
append exp ")"
set exprr2 "\[ \\t\\n\\r\]+$exp\"?(\[^ \\t\\n\\r\">\]+)\"?"
set num 0
foreach f $movedFiles2 {
getFileInfo $f finfo
if {$finfo(type) != "TEXT"} {continue}
message "Modifying [file tail $f]…"
set fid [open $f r]
set filecont [read $fid]
close $fid
set oldfile [lindex $movedFiles [lsearch -exact $movedFiles2 $f]]
set base $fromBase
set path $fromPath
set hpPath $homepage
set epath [string range $oldfile [expr [string length $homepage] + 1] end]
regsub -all {:} $epath {/} epath
# Replace newline chars in IBM files.
regsub -all "\n\r" $filecont "\r" filecont
# If BASE is used, only modify links to moved files.
if {[regexp -nocase $expBase $filecont this] && \
[regexp -nocase $expBase2 $this d1 d2 url1]} {
set hasBase 1
} else {
set hasBase 0
}
if {$hasBase && ![catch {htmlBASEpieces $url1} basestr]} {
set base [lindex $basestr 0]
set path [lindex $basestr 1]
set epath [lindex $basestr 2]
set hpPath ""
}
incr num
set newcont ""
while {[regexp -nocase -indices $exprr2 $filecont href b url]} {
set urltxt [string range $filecont [lindex $url 0] [lindex $url 1]]
set anchor ""
regexp {[^#]*(#[^\"]*)} $urltxt a anchor
set urltxt [htmlURLunEscape $urltxt]
if {[catch {lindex [htmlPathToFile $base $path $epath $hpPath $urltxt] 0} topath]} {set topath ""}
# Ignore anchors if not moved and BASE.
# Is the link pointing to a previously moved file?
if {[set mvind [lsearch -exact $movedFiles $topath]] >= 0} {
set topath [lindex $movedFiles2 $mvind]
if {!$hasBase && [string index $urltxt 0] == "#"} {set topath ""}
} elseif {[string index $urltxt 0] == "#"} {
set topath ""
}
if {$hasBase && [regexp -nocase -indices $expBase $filecont thisLine] \
&& [regexp -nocase $expBase2 [string range $filecont [lindex $thisLine 0] [lindex $thisLine 1]]]\
&& [lindex $thisLine 0] < [lindex $url 0] && [lindex $thisLine 1] > [lindex $url 1]} {
set topath ""
}
if {[string length $topath]} {
set lnk [htmlBASEfromPath $topath]
if {!$hasBase} {
set lnk1 [htmlBASEfromPath $f]
set path2 [lindex $lnk1 1]
set epath2 [lindex $lnk1 2]
} else {
set path2 $path
set epath2 $epath
}
if {$base == [lindex $lnk 0]} {
set newurl [htmlRelativePath "$path2$epath2" "[lindex $lnk 1][lindex $lnk 2]"]
} else {
set newurl [join [lrange $lnk 0 2] ""]
}
append newurl $anchor
} elseif {!$hasBase && ($urltxt == ".." || [string range $urltxt 0 2] == "../")} {
# Special case with relative links outside home page.
set urlspl [split $urltxt /]
set old [split $oldfile :]
set new [split $f :]
if {[llength $new] > [llength $old]} {
set newurl ""
for {set i 0} {$i < [expr [llength $new] - [llength $old]]} {incr i} {
append newurl "../"
}
append newurl $urltxt
} else {
set ok 1
for {set i 0} {$i < [expr [llength $old] - [llength $new]]} {incr i} {
if {[lindex $urlspl $i] != ".."} {set ok 0}
}
if {$ok} {
set newurl "[join [lrange $urlspl [expr [llength $old] - [llength $new]] end] /]$anchor"
} else {
set newurl $urltxt
}
}
} else {
set newurl $urltxt
}
append newcont [string range $filecont 0 [expr [lindex $url 0] - 1]]
append newcont [htmlURLescape2 $newurl]
set filecont [string range $filecont [expr [lindex $url 1] + 1] end]
}
append newcont $filecont
if {[catch {open $f w} fid]} {
alertnote "Could not update [file tail $f]. An error ocurred."
} else {
puts -nonewline $fid $newcont
close $fid
}
}
return $num
}
# Updates include links to moved files in include folder.
proc htmlUpdateAfterMove3 {movedFiles movedFiles2 homepage} {
set num 0
set changed ""
foreach fil [htmlAllHTMLfiles $homepage] {
if {[catch {open $fil r} fid]} {continue}
set filecont [read $fid]
close $fid
message "Looking at [file tail $fil]…"
regsub -all "\n\r" $filecont "\r" filecont
set newcont ""
set ismod 0
while {[regexp -nocase -indices {<!--[ \t\r\n]+#INCLUDE[ \t\r\n]+[^>]+>} $filecont res]} {
set link [string range $filecont [lindex $res 0] [lindex $res 1]]
if {[regexp -nocase -indices {FILE=\"([^\"]+)\"} $link dum res1] &&
[set ind [lsearch -exact $movedFiles [htmlUnQuote [string range $link [lindex $res1 0] [lindex $res1 1]]]]] >= 0} {
append newcont [string range $filecont 0 [expr [lindex $res 0] + [lindex $res1 0] - 1]]
append newcont [htmlQuote [lindex $movedFiles2 $ind]]
append newcont [string range $filecont [expr [lindex $res 0] + [lindex $res1 1] + 1] [lindex $res 1]]
set ismod 1
message "Modifying [file tail $fil]…"
} else {
append newcont [string range $filecont 0 [lindex $res 1]]
}
set filecont [string range $filecont [expr [lindex $res 1] + 1] end]
}
if {$ismod} {
if {[catch {open $fil w} fid]} {
alertnote "Could not update [file tail $fil]. An error occured."
} else {
puts -nonewline $fid "$newcont$filecont"
close $fid
}
incr num
foreach w [winNames -f] {
if {[stripNameCount $w] == "$fil"} {
lappend changed $w
}
}
}
}
return [list $num $changed]
}
#
# dividing line
#
proc htmlDividingLine {} {
global HTMLmodeVars fillColumn
set wordWrap $HTMLmodeVars(wordWrap)
set comStr [htmlCommentStrings]
set prefixString [lindex $comStr 0]
set suffixString [lindex $comStr 1]
set s "===================================================================================="
set l [expr [string length $prefixString] + [string length $suffixString]]
if {$wordWrap} {
set l [expr $fillColumn - $l - 1]
} else {
set l [expr 75 - $l - 1]
}
insertText [htmlOpenCR] $prefixString [string range $s 0 $l] $suffixString "\r"
}
# Removes all tab marks from the current selection (if there is one)
# or the current document, maintaining the cursor position in the
# latter case. Stolen from latexMacros.tcl written by Tom Scavo.
proc htmlTabDeleteAll {} {
set subs1 0; set subs2 0; set subs3 0
set pos [getPos]
if {[set start $pos] == [set end [selEnd]]} {
set messageString "document"
set start 0
set end [maxPos]
set text1 [getText $start $pos]
set subs1 [regsub -all {•} $text1 {} text1]
set text2 [getText $pos $end]
set subs2 [regsub -all {•} $text2 {} text2]
append text $text1 $text2
} else {
set messageString "selection"
set text [getText $start $end]
set subs3 [regsub -all {•} $text {} text]
}
if {$subs1 || $subs2 || $subs3} then {
replaceText $start $end $text
if {$messageString == "document"} then {
goto [expr $pos - $subs1]
} else {
set end [getPos]
select $start $end
}
set subs [expr $subs1 + $subs2 + $subs3]
message "$subs tab marks removed from $messageString."
} else {
message "No tab marks found in $messageString."
}
}
#
# Converting characters to HTML entities.
#
# 1 = < > &
# 0 = áé etc.
proc htmlCharacterstohtml {ltgtamp} {
global htmlSpecialCharacter
global htmlSpecialCapCharacter htmlSpecialSymbCharacter
if {$ltgtamp} {
set charlist {& < >}
} else {
foreach a [array names htmlSpecialCharacter] {
if { $a != "eth" && $a != "thorn" && $a != "y´"} {
lappend charlist $a
}
}
foreach a [array names htmlSpecialCapCharacter] {
if {$a != "ETH" && $a != "THORN" && $a != "Y´"} {
lappend charlist $a
}
}
lappend charlist ¡ ¿
}
set subs1 0; set lett 0
set pos [getPos]
if {[set start $pos] == [set end [selEnd]]} {
if {$ltgtamp && \
[askyesno "There is no selection. Really translate < > & in whole document?"] == "no"} {return}
set messageString "document"
set start 0
set end [maxPos]
set isDoc 1
} else {
set messageString "selection"
set isDoc 0
}
message "Translating…"
set text [getText $start $end]
set tmp $text
set upos $pos
set st $start
if {!$ltgtamp} {
while {[regexp -indices -nocase {<!--[ \t\r]+#(INCLUDE|LASTMODIFIED)[ \t\r]+[^>]+>} $tmp str]} {
set sv [string range $tmp [lindex $str 0] [lindex $str 1]]
if {[expr $st + [lindex $str 1]] < $upos} {
incr pos [expr 17 - [string length $sv]]
} elseif {[expr $st + [lindex $str 0]] < $upos} {
incr pos [expr $st + [lindex $str 0] - $upos]
}
lappend savestr $sv
set tmp [string range $tmp [lindex $str 1] end]
incr st [lindex $str 1]
}
regsub -all -nocase "<!--\[ \t\r\]+#(INCLUDE|LASTMODIFIED)\[ \t\r\]+\[^>\]+>" $text {<!-- #INCLUDE -->} text
}
if {$isDoc} {
set text1 [string range $text 0 [expr $pos - $start - 1]]
set text2 [string range $text [expr $pos - $start] end]
} else {
set text1 $text
}
foreach char $charlist {
if {[info exists htmlSpecialCharacter($char)]} {
set rtext "\\&$htmlSpecialCharacter($char);"
} elseif {[info exists htmlSpecialCapCharacter($char)]} {
set rtext "\\&$htmlSpecialCapCharacter($char);"
} elseif {[info exists htmlSpecialSymbCharacter($char)]} {
set rtext "\\&$htmlSpecialSymbCharacter($char);"
} elseif {$char == ">"} {
set rtext "\\>"
} elseif {$char == "<"} {
set rtext "\\<"
} elseif {$char == "&"} {
set rtext "\\&"
}
set subNum [regsub -all $char $text1 [set rtext] text1]
incr subs1 [expr $subNum * ([string length $rtext] - 2)]
incr lett $subNum
if {$isDoc} {
incr lett [regsub -all $char $text2 [set rtext] text2]
}
}
set text $text1
if {$isDoc} {append text $text2}
if {$lett} {
if {[info exists savestr]} {
set i 0
set tmp ""
while {[regexp -indices -nocase {<!--[ \t\r]+#(INCLUDE|LASTMODIFIED)[ \t\r]+[^>]+>} $text str]} {
append tmp [string range $text 0 [expr [lindex $str 0] - 1]]
append tmp [lindex $savestr $i]
set text [string range $text [expr [lindex $str 1] + 1] end]
incr i
}
set text "$tmp$text"
}
replaceText $start $end $text
if {$isDoc} {
goto [expr $upos + $subs1]
} else {
set end [getPos]
select $start $end
}
}
message "$lett characters translated in $messageString."
}
#
# Converting HTML entities to characters.
#
# 1 = < > &
# 0 = áé etc.
proc htmltoCharacters {ltgtamp} {
global htmlCharacterSpecial
global htmlCapCharacterSpecial
message "Translating…"
if {$ltgtamp} {
set entitylist {"&" "<" ">"}
} else {
foreach a [array names htmlCharacterSpecial] {
if { $a != "eth" && $a != "thorn" && $a != "y´"} {
lappend entitylist "&$a;"
}
}
foreach a [array names htmlCapCharacterSpecial] {
if {$a != "ETH" && $a != "THORN" && $a != "Y´"} {
lappend entitylist "&$a;"
}
}
# ¡ ¿
lappend entitylist "¡" "¿"
}
set subs1 0; set lett 0
set pos [getPos]
if {[set start $pos] == [set end [selEnd]]} {
# Move position to linestart to make sure no letter is split.
set pos [lineStart $pos]
set messageString "document"
set start 0
set end [maxPos]
set isDoc 1
} else {
set messageString "selection"
set isDoc 0
}
set text [getText $start $end]
set tmp $text
set upos $pos
set st $start
if {!$ltgtamp} {
while {[regexp -indices -nocase {<!--[ \t\r]+#(INCLUDE|LASTMODIFIED)[ \t\r]+[^>]+>} $tmp str]} {
set sv [string range $tmp [lindex $str 0] [lindex $str 1]]
if {[expr $st + [lindex $str 1]] < $upos} {
incr pos [expr 17 - [string length $sv]]
} elseif {[expr $st + [lindex $str 0]] < $upos} {
incr pos [expr $st + [lindex $str 0] - $upos]
}
lappend savestr $sv
set tmp [string range $tmp [lindex $str 1] end]
incr st [lindex $str 1]
}
regsub -all -nocase "<!--\[ \t\r\]+#(INCLUDE|LASTMODIFIED)\[ \t\r\]+\[^>\]+>" $text {<!-- #INCLUDE -->} text
}
if {$isDoc} {
set text1 [string range $text 0 [expr $pos - $start - 1]]
set text2 [string range $text [expr $pos - $start] end]
} else {
set text1 $text
}
foreach char $entitylist {
set schar [string range $char 1 [expr [string length $char] - 2]]
if {[info exists htmlCharacterSpecial($schar)]} {
set rtext "$htmlCharacterSpecial($schar)"
} elseif {[info exists htmlCapCharacterSpecial($schar)]} {
set rtext "$htmlCapCharacterSpecial($schar)"
} elseif {$schar == "#161"} {
set rtext ¡
} elseif {$schar == "#191"} {
set rtext ¿
} elseif {$schar == "amp"} {
set rtext "\\&"
} elseif {$schar == "lt"} {
set rtext "<"
} elseif {$schar == "gt"} {
set rtext ">"
}
set subNum [regsub -all $char $text1 $rtext text1]
incr subs1 [expr $subNum * ([string length $char] - 1)]
incr lett $subNum
if {$isDoc} {
incr lett [regsub -all $char $text2 $rtext text2]
}
}
set text $text1
if {$isDoc} {append text $text2}
if {$lett} {
if {[info exists savestr]} {
set i 0
set tmp ""
while {[regexp -indices -nocase {<!--[ \t\r]+#(INCLUDE|LASTMODIFIED)[ \t\r]+[^>]+>} $text str]} {
append tmp [string range $text 0 [expr [lindex $str 0] - 1]]
append tmp [lindex $savestr $i]
set text [string range $text [expr [lindex $str 1] + 1] end]
incr i
}
set text "$tmp$text"
}
replaceText $start $end $text
if {$isDoc} {
goto [expr $upos - $subs1]
} else {
set end [getPos]
select $start $end
}
}
message "$lett characters translated in $messageString."
}
#===============================================================================
# HTML character entities
#===============================================================================
proc htmlAddCommonChars {} {
global modifiedModeVars HTMLmodeVars htmlSpecialCharacter htmlCapCharSpecMenu
global htmlSpecialSymbCharacter
set commonChars $HTMLmodeVars(commonChars)
set htmlCharacters [lsort [array names htmlSpecialCharacter]]
set htmlCapCharacters [lsort [array names htmlCapCharSpecMenu]]
set htmlSymbCharacters [lsort [array names htmlSpecialSymbCharacter]]
set htmlAllCharacters [concat $htmlCharacters $htmlCapCharacters $htmlSymbCharacters]
if {![catch {listpick -l -p "Select chars for the commonly used char list" \
$htmlAllCharacters} newchars]} {
set dirty 0
foreach c $newchars {
if {[lsearch -exact $commonChars $c] < 0} {
set dirty 1
set commonChars [lsort [lappend commonChars $c]]
}
}
if {$dirty} {
lappend modifiedModeVars {commonChars HTMLmodeVars}
set HTMLmodeVars(commonChars) $commonChars
message "Rebuiding HTML menu…"
htmlBuildMenu
message "New characters added to the common list."
}
}
}
proc htmlDefaultCommonChars {} {
global modifiedModeVars HTMLmodeVars
if {[askyesno "Revert to default common characters?"] == "yes"} {
set HTMLmodeVars(commonChars) $HTMLmodeVars(defaultCommonChars)
lappend modifiedModeVars {commonChars HTMLmodeVars}
message "Rebuiding HTML menu…"
htmlBuildMenu
message "Common character list reverted to default."
}
}
proc htmlClearCommonChars {} {
global modifiedModeVars HTMLmodeVars
if {[askyesno "Remove all common characters?"] == "yes"} {
set HTMLmodeVars(commonChars) {}
lappend modifiedModeVars {commonChars HTMLmodeVars}
message "Rebuiding HTML menu…"
htmlBuildMenu
message "Common character list cleared."
}
}
#
# Insert special character entity
#
proc htmlInsertCharacter {char} {
global htmlSpecialCharacter htmlCapCharSpecMenu htmlSpecialSymbCharacter
if {[isSelection]} { deleteSelection }
foreach c [list SpecialCharacter CapCharSpecMenu SpecialSymbCharacter] {
if {[info exists html${c}($char)]} {
insertText &[set html${c}($char)]\;
}
}
}
#===============================================================================
# General Commands
#===============================================================================
# remove containing tags
proc htmlUnTag {selectit} {
set curPos [getPos]
set tags [htmlGetContainer $curPos [selEnd]]
if {[llength $tags] < 5} {
alertnote "Cannot decide on enclosing tags."
return
}
# delete them
replaceText [lindex $tags 0] [lindex $tags 3] \
[getText [lindex $tags 1] [lindex $tags 2]]
if {$selectit} {
select [lindex $tags 0] \
[expr [lindex $tags 2] - [lindex $tags 1] + [lindex $tags 0]]
} else {
if {$curPos < [lindex $tags 1]} {set curPos [lindex $tags 1]}
if {$curPos > [lindex $tags 2]} {set curPos [lindex $tags 2]}
goto [expr $curPos - [lindex $tags 1] + [lindex $tags 0]]
}
message "[lindex $tags 4] deleted."
}
# select container, like Balance (cmd-B)
proc htmlBalance {inside} {
set start [getPos]
if {$start != 0 &&
![catch {getText $start [expr $start + 2]} lookingAt] &&
$lookingAt != "</" &&
[string range $lookingAt 0 0] == "<"} {
incr start -1
}
set tags [htmlGetContainer $start [selEnd]]
if {[llength $tags] == 5} {
if {$inside} {
select [lindex $tags 1] [lindex $tags 2]
} else {
select [lindex $tags 0] [lindex $tags 3]
}
message "[lindex $tags 4] selected."
} else {
beep
message "Cannot decide on enclosing tags."
}
}
# Select an opening tag, or remove it, of an element without a closing tag.
proc htmlSelectOpening {remove} {
set begin [getPos]
# back up one if possible and selection is wanted.
if {$begin >0 && !$remove} {incr begin -1}
set tag [htmlGetOpening $begin]
if {[llength $tag] == 3} {
if {$remove} {
deleteText [lindex $tag 0] [lindex $tag 1]
if {$begin < [lindex $tag 1]} {set begin [lindex $tag 1]}
goto [expr $begin - [lindex $tag 1] + [lindex $tag 0]]
message "[lindex $tag 2] deleted."
} else {
select [lindex $tag 0] [lindex $tag 1]
message "[lindex $tag 2] selected."
}
} else {
if {$remove} {
alertnote "Cannot find opening tag."
} else {
beep
message "Cannot find opening tag."
}
}
}
# Change an existing element.
proc htmlChangeContainer {} {
set tag [htmlGetContainer [getPos] [selEnd]]
if {[llength $tag] == 5} {
set newTag [htmlChangeElement [getText [expr [lindex $tag 0] + 1] \
[expr [lindex $tag 1] - 1]] [lindex $tag 4] [lindex $tag 0]]
if {[string length $newTag]} {
replaceText [lindex $tag 0] [lindex $tag 1] $newTag
}
} else {
alertnote "Cannot decide on enclosing tags."
}
}
proc htmlChangeOpening {} {
set tag [htmlGetOpening [getPos]]
if {[llength $tag] == 3} {
set newTag [htmlChangeElement [getText [expr [lindex $tag 0] + 1] \
[expr [lindex $tag 1] - 1]] [lindex $tag 2] [lindex $tag 0]]
if {[string length $newTag]} {
replaceText [lindex $tag 0] [lindex $tag 1] $newTag
}
} else {
alertnote "Cannot find opening tag."
}
}
#
# Exstracts all attributes to a element from a list, and puts up a dialog window
# where the user can change the attributes.
#
proc htmlChangeElement {tag elem {wrPos 0}} {
global htmlColorAttr htmlURLAttr HTMLmodeVars
global htmluserColorname htmlColorNumber htmlPackageToUse
global htmlElemAttrOptional1 htmlElemAttrOptional3
global htmlElemEventHandler1 htmlWindowAttr htmlPlugins
global htmlSpecURL htmlSpecColor htmlSpecWindow
# Remove tabs and returns from list.
regsub -all "\[\t\r\]+" $tag " " tag
# Remove element name.
set tagelem [lindex $tag 0]
set tag [string range $tag [string length $tagelem] end]
set attrs ""
set attrVals ""
# Exstract the attributes.
while {[regexp {[ ]+([^ "]+"[^"]*"|[^ "]+)} $tag thisatt]} {
set tag [string range $tag [string length $thisatt] end]
set thisatt [htmlRemoveQuotes $thisatt]
lappend attrs [string trim [lindex $thisatt 0]]
lappend attrVals [lindex $thisatt 1]
}
# All INPUT elements are defined differently. Must extract TYPE.
if {$elem == "INPUT"} {
set typeIndex [lsearch -exact [string toupper $attrs] "TYPE="]
if {$typeIndex >= 0 } {
set elem [string toupper [lindex $attrVals $typeIndex]]
# Remove TYPE attribute from list.
set attrs [lreplace $attrs $typeIndex $typeIndex]
set attrVals [lreplace $attrVals $typeIndex $typeIndex]
set used "INPUT TYPE=\"${elem}\""
} else {
beep
message "INPUT element without a TYPE attribute."
return
}
} else {
set used $elem
}
# If EMBED element, choose which
if {$elem == "EMBED" && $htmlPackageToUse == 1} {
if {[catch {listpick -p "Which plug-in?" [lsort $htmlPlugins]} elem] || ![string length $elem]} {return}
}
# If LI element and Extensions package, check in which list.
if {$elem == "LI"} {
set ltype [htmlFindList]
if {$ltype == "UL"} {
set elem "LI IN UL"
} elseif {$ltype == "OL"} {
set elem "LI IN OL"
}
}
set eventText ""
# JavaScript event handlers. Extension package only.
if {$htmlPackageToUse == 1 && [info exists htmlElemEventHandler1($elem)]} {
set eventHandler [string toupper $htmlElemEventHandler1($elem)]
} else {
set eventHandler ""
}
# Remove event handler from attributes list,
# if they should not be included, and save them to put them back later.
set attrsToupper [string toupper $attrs]
if {!$HTMLmodeVars(inclEventHandler)} {
foreach ev $eventHandler {
set evIndex [lsearch -exact $attrsToupper $ev]
if {$evIndex >=0} {
append eventText " " [lindex $attrs $evIndex] \
[htmlAddQuotes [lindex $attrVals $evIndex]]
set attrs [lreplace $attrs $evIndex $evIndex]
set attrVals [lreplace $attrVals $evIndex $evIndex]
set attrsToupper [lreplace $attrsToupper $evIndex $evIndex]
}
}
}
set attrs $attrsToupper
# Element known by HTML mode?
if {![info exists htmlElemAttrOptional${htmlPackageToUse}($elem)]} {
alertnote "Unknown element: $elem"
return
}
set allAttrs [concat [htmlGetRequired $elem] [htmlGetOptional $elem]]
if {[string length $eventHandler]} {append allAttrs " " $eventHandler}
set choices [htmlGetChoices $elem]
set numAttrs [htmlGetNumber $elem]
set errText ""
# Check if there are some unknown attributes.
foreach a $attrs {
if {[lsearch -exact $allAttrs $a] < 0} {
lappend errText "Unknown attribute: $a"
}
}
# Does this element have any attributes?
if {![llength $allAttrs]} {
if {[llength $errText]} {
if {[askyesno "$elem has no attributes. Remove the ones in the text?"] == "no"} {
return
} else {
# Remove the error text to prevent another popup window.
set errText ""
}
} else {
beep
message "$elem has no attributes."
return
}
}
# Add two dummy elements for OK and Cancel buttons.
set values {0 0}
# Build a list with attribute vales.
foreach a $allAttrs {
set attrIndex [lsearch -exact $attrs $a]
if {$attrIndex >= 0 } {set aval [lindex $attrVals $attrIndex]}
set a2 [string trimright $a =]
if {[string index $a [expr [string length $a] - 1]] != "="} {
# Flag
if {$attrIndex >= 0} {
lappend values 1
} else {
lappend values 0
}
} elseif {([lsearch -exact $htmlURLAttr $a] >= 0 && [lsearch -exact $htmlSpecURL "${elem}!=$a2"] < 0) || \
[lsearch -exact $htmlSpecURL "${elem}=$a2"] >= 0} {
# URL
if {$attrIndex >= 0} {
set aval [htmlURLunEscape $aval]
htmlAddToCache URLs $aval
lappend values "" $aval 0
} else {
lappend values "" "No value" 0
}
} elseif {([lsearch -exact $htmlColorAttr $a] >= 0 && [lsearch -exact $htmlSpecColor "${elem}!=$a2"] < 0) || \
[lsearch -exact $htmlSpecColor "${elem}=$a2"] >= 0} {
# Color
if {$attrIndex >= 0} {
set aval [htmlCheckColorNumber $aval]
if {$aval == 0} {
lappend errText "$a: Invalid color number."
lappend values "" "No value" 0
} elseif {[info exists htmluserColorname($aval)]} {
lappend values "" $htmluserColorname($aval) 0
} elseif {[info exists htmlColorNumber($aval)]} {
lappend values "" $htmlColorNumber($aval) 0
} else {
lappend values $aval "No value" 0
}
} else {
lappend values "" "No value" 0
}
} elseif {([lsearch -exact $htmlWindowAttr $a] >= 0 && [lsearch -exact $htmlSpecWindow "${elem}!=$a2"] < 0) || \
[lsearch -exact $htmlSpecWindow "${elem}=$a2"] >= 0} {
# Window
if {$attrIndex >= 0} {
htmlAddToCache windows $aval
lappend values "" $aval
} else {
lappend values "" "No value"
}
} elseif {[lsearch $numAttrs "${a}*"] >= 0} {
# Number
if {$attrIndex >= 0} {
set numcheck [htmlCheckAttrNumber $elem $a $aval]
if {$numcheck == 1} {
lappend values $aval
} else {
lappend errText "$a: $numcheck"
lappend values ""
}
} else {
lappend values ""
}
} elseif {[lsearch $choices "${a}*"] >= 0} {
# Choices
if {$attrIndex >= 0} {
set match ""
if {!(($elem == "OL" || $elem == "LI IN OL") && $a == "TYPE=")} {
set aval [string toupper $aval]
}
foreach w $choices {
if {$w == "${a}${aval}"} {
set match $aval
}
}
if {[string length $match]} {
lappend values $match
} else {
lappend errText "$a: Unknown choice, $aval."
lappend values "No value"
}
} else {
lappend values "No value"
}
} elseif {$attrIndex >= 0} {
# Any other
lappend values $aval
} else {
lappend values ""
}
}
# If invalid attributes, continue?
if {[llength $errText] && ![htmlErrorWindow "$elem not well-defined" $errText 1]} {
return
}
set r [htmlOpenElemWindow $used $elem [lindex [posToRowCol $wrPos] 1] $values]
# Put back event handlers. Empty string means "Cancel", do nothing.
if {[string length $r]} {
set r "[string range $r 0 [expr [string length $r] - 2]]$eventText>"
}
return $r
}
# opens the manual in the browser.
proc htmlManual {} {
global HOME HTMLmodeVars modifiedModeVars
set path "$HOME:HTML mode manual:HTMLmanual.html"
if {$HTMLmodeVars(manualFolder) != ""} {set path "$HTMLmodeVars(manualFolder):HTMLmanual.html"}
if {![file exists $path]} {
if {![catch {htmlGetDir "Locate manual"} folder]} {
set path "$folder:HTMLmanual.html"
if {![file exists $path]} {
alertnote "Folder doesn't contain the HTML manual."
return
}
set HTMLmodeVars(manualFolder) $folder
lappend modifiedModeVars {manualFolder HTMLmodeVars}
} else {
return
}
}
htmlSendWindow $path
}
#
# launch a viewer and pass this window to it
#
proc htmlSendWindow {{path ""}} {
global HTMLmodeVars browserSig
if {$path == ""} {
set path [stripNameCount [car [winNames -f]]]
if {[winDirty]} {
if {$HTMLmodeVars(saveWithoutAsking) || [set ask [askyesno -c "Save '[file tail $path]'?"]] == "yes"} {
save
} elseif {$ask == "cancel"} {
return
} elseif {![file exists $path]} {
alertnote "Can't send window to browser."
return
}
}
# Get path again, in case it was Untitled before.
set path [stripNameCount [car [winNames -f]]]
}
if {![info exists browserSig]} {set browserSig MOSS}
set isRunning 0
foreach p [processes] {
if {[lindex $p 1] == $browserSig } {
set isRunning 1
}
}
if {!$isRunning && [catch {launchBackAppl $browserSig}]} {
getApplSig "Please locate your web browser" browserSig
launchBackAppl $browserSig
}
sendOpenEvent noReply '$browserSig' $path
if {$HTMLmodeVars(browseInForeground)} { switchTo '$browserSig' }
}
#===============================================================================
# Caches
#===============================================================================
proc htmlCleanUpCache {cache} {
global HTMLmodeVars
global modifiedModeVars
set URLs $HTMLmodeVars($cache)
if {![llength $URLs]} {
alertnote "No $cache are cached."
return
}
set urlnumber [llength $URLs]
set screenHeight [lindex [getMainDevice] 3]
set maxLines [expr ($screenHeight - 160) / 20]
set pages [expr ($urlnumber - 1) / $maxLines ]
set thispage 0
for {set i 0} {$i < $urlnumber} {incr i} {
lappend URLsToSave 1
}
set thisbox $URLsToSave
while {1} {
if {$thispage < $pages} {
set thisurlnumber $maxLines
} else {
set thisurlnumber [expr ($urlnumber - 1 ) % $maxLines + 1]
}
set height [expr 75 + $thisurlnumber * 20]
set box "-w 440 -h $height -b OK 20 [expr $height - 30] 85 [expr $height - 10] \
-b Cancel 100 [expr $height - 30] 165 [expr $height - 10] \
-b {Uncheck all} 180 [expr $height - 30] 265 [expr $height - 10] \
-t {Uncheck the $cache you want to remove} 10 10 440 30 "
if {$thispage < $pages} {
lappend box -b "More…" 280 [expr $height - 30] 345 [expr $height - 10]
}
if {$thispage > 0} {
lappend box -b "Back…" 360 [expr $height - 30] 425 [expr $height - 10]
}
set hpos 30
set thisURLs [lrange $URLs [expr $thispage * $maxLines] \
[expr $thispage * $maxLines + $maxLines - 1]]
set i 0
foreach url $thisURLs {
lappend box -c $url [lindex $thisbox $i] 10 $hpos 430 [expr $hpos + 15]
incr i
incr hpos 20
}
set thisbox [eval [concat dialog $box]]
if {[lindex $thisbox 1]} {
# cancel
return
} elseif {[lindex $thisbox 2]} {
# uncheck all
set thisbox {}
for {set i 0} {$i < [llength $thisbox]} {incr i} {
lappend thisbox 0
}
} else {
if {$pages == 0} {
set ll 3
} elseif {$thispage == 0 || $thispage == $pages} {
set ll 4
} else {
set ll 5
}
set URLsToSave [eval [concat lreplace [list $URLsToSave] [expr $thispage * $maxLines] \
[expr $thispage * $maxLines + $maxLines - 1] [lrange $thisbox $ll end]]]
if {[lindex $thisbox 0]} {
# OK
break
} elseif {$thispage < $pages && [lindex $thisbox 3]} {
# more
incr thispage 1
set thisbox [lrange $URLsToSave [expr $thispage * $maxLines] \
[expr $thispage * $maxLines + $maxLines - 1]]
} else {
# back
incr thispage -1
set thisbox [lrange $URLsToSave [expr $thispage * $maxLines] \
[expr $thispage * $maxLines + $maxLines - 1]]
}
}
}
set newurls {}
for {set i 0} {$i < $urlnumber} {incr i} {
if {[lindex $URLsToSave $i]} {
lappend newurls [lindex $URLs $i]
}
}
set HTMLmodeVars($cache) $newurls
lappend modifiedModeVars [list $cache HTMLmodeVars]
if {![llength $newurls]} {htmlEnable$cache off}
}
proc htmlSelScrapToURL {sel msg1 msg2} {
set newurl [htmlURLunEscape [string trim [eval get$sel]]]
# Convert tabs and returns.
if {[regexp {[\t\r\n]} $newurl]} {
alertnote "$msg1 contains tabs or returns. It will not be added to the URL cache."
return
}
if {[string length $newurl]} {
htmlAddToCache URLs $newurl
message "$newurl added to URLs."
} else {
beep
message $msg2
}
}
proc htmlSelToURL {} {
htmlSelScrapToURL Select Selection "No selection!"
}
proc htmlScrapToURL {} {
htmlSelScrapToURL Scrap Clipboard "Clipboard empty!"
}
proc htmlClearCache {cache} {
global HTMLmodeVars modifiedModeVars
if {[askyesno "Remove all $cache from [string range $cache 0 [expr [string length $cache] - 2]] cache?"] == "yes"} {
set HTMLmodeVars($cache) {}
lappend modifiedModeVars [list $cache HTMLmodeVars]
htmlEnable$cache off
}
}
# Imports all URLs in a file to the cache.
proc htmlImportURL {} {
global HTMLmodeVars modifiedModeVars htmlURLAttr
set urls $HTMLmodeVars(URLs)
if {[catch {getfile "Import URLs from:"} fil] || ![htmlIsTextFile $fil alertnote]} {return}
set fid [open $fil r]
set filecont " [read $fid]"
close $fid
if {[llength $urls]} {
set cl [askyesno -c "Clear URL cache before importing?"]
if {$cl == "cancel"} {
return
} elseif {$cl == "yes"} {
set urls {}
}
}
set exp "\[ \\t\\n\\r\]+("
foreach attr $htmlURLAttr {
append exp "$attr|"
}
set exp [string trimright $exp |]
# append exp ")\"?(\[^ \\t\\n\\r\">\]+)\"?"
append exp ")(\"\[^\">\]+\"|\[^ \\t\\n\\r>\]+)"
while {[regexp -nocase -indices $exp $filecont a b url]} {
set link [string range $filecont [lindex $url 0] [lindex $url 1]]
set filecont [string range $filecont [lindex $url 1] end]
if {[lsearch -exact $urls $link] < 0} {
lappend urls [htmlURLunEscape [string trim $link \"]]
}
}
set HTMLmodeVars(URLs) [lsort $urls]
lappend modifiedModeVars {URLs HTMLmodeVars}
htmlEnableURLs [expr ([llength $HTMLmodeVars(URLs)] > 0)]
message "URLs imported."
}
# Export URLs in cache to a file.
proc htmlExportURL {} {
global HTMLmodeVars
if {![llength $HTMLmodeVars(URLs)]} {
alertnote "URL cache is empty."
return
}
foreach url $HTMLmodeVars(URLs) {
lappend out "HREF=\"$url\""
}
if {![catch {putfile "Export URL cache to:" "URL cache"} fil]} {
if {[file exists $fil]} {removeFile $fil}
set fid [open $fil w]
puts $fid [join $out "\n"]
close $fid
message "URLs exported."
}
}
# Add all files in a folder to URL cache.
proc htmlFolderToURL {} {
global HTMLmodeVars modifiedModeVars
if {[catch {htmlGetDir "Folder to cache:"} folder]} {return}
set path ""
foreach hp $HTMLmodeVars(homePages) {
if {[string match "[lindex $hp 0]:*" "$folder:"]} {
set path [string range $folder [expr [string length [lindex $hp 0]] +1] end]
regsub -all {:} $path {/} path
if {[string length $path]} {append path /}
}
}
set val [dialog -w 350 -h 80 -t "Path:" 10 10 60 30 -e $path 70 10 340 25 \
-b OK 20 50 85 70 -b Cancel 110 50 175 70]
if {[lindex $val 2]} {return}
set path [string trim [lindex $val 0]]
if {[string length $path]} {set path "[string trimright $path /]/"}
set urls $HTMLmodeVars(URLs)
if {[llength $urls]} {
set cl [askyesno -c "Clear URL cache first?"]
if {$cl == "cancel"} {
return
} elseif {$cl == "yes"} {
set urls {}
}
}
foreach fil [glob -nocomplain "$folder:*"] {
set name [file tail $fil]
if {![file isdirectory $fil] && [lsearch -exact $urls "$path$name"] < 0} {
lappend urls "$path$name"
}
}
set HTMLmodeVars(URLs) [lsort $urls]
lappend modifiedModeVars {URLs HTMLmodeVars}
htmlEnableURLs [expr ([llength $HTMLmodeVars(URLs)] > 0)]
message "Files added to URL cache."
}
#==============================================================================
# Colors
#==============================================================================
# Convert colour names to numbers and vice versa.
# Or brings up a color picker if cmd-doubleClick.
proc htmlRevealColor {{dblClick 0}} {
global htmlColorName htmlColorNumber htmlColorAttr htmluserColors
global htmluserColorname
set searchstring "("
foreach s $htmlColorAttr {
append searchstring "${s}|"
}
# remove last |
set searchstring [string trimright $searchstring |]
append searchstring ")((\[^ \\t\\r\">\]+)|\"(\[^\"\]+)\")"
set startpos [getPos]
set endpos [selEnd]
set cantfind 0
# find attribute
set f [search -s -f 0 -r 1 -i 1 -n -m 0 $searchstring $startpos]
if {![string length $f] || [lindex $f 1] < $endpos} {
set cantfind 1
}
if {!$cantfind} {
set txt [getText [lindex $f 0] [lindex $f 1]]
regexp -indices -nocase $searchstring $txt a b c
set cpos [expr [lindex $f 0] + [lindex $c 0]]
set epos [expr [lindex $f 0] + [lindex $c 1] + 1]
set col [string trim [string range $txt [lindex $c 0] [lindex $c 1]] \"]
if {!$dblClick} {
if {[info exists htmlColorName($col)]} {
replaceText $cpos $epos "\"$htmlColorName($col)\""
} elseif {[info exists htmlColorNumber($col)]} {
replaceText $cpos $epos "\"$htmlColorNumber($col)\""
} elseif {[info exists htmluserColorname($col)]} {
replaceText $cpos $epos "\"$htmluserColorname($col)\""
} elseif {[info exists htmluserColors($col)]} {
replaceText $cpos $epos "\"$htmluserColors($col)\""
} else {
beep
message "Don't recognize color."
}
} else {
if {[set ncol [htmlCheckColorNumber $col]] != "0"} {
set ncol [htmlHexColor $ncol]
} else {
set ncol {65535 65535 65535}
}
set newcolor [eval [concat colorTriple {{Change color}} $ncol]]
if {[string length $newcolor]} {
replaceText $cpos $epos "\"[htmlColorHex $newcolor]\""
}
return 1
}
} elseif {!$dblClick} {
beep
message "Current position is not at a color attribute."
} else {
return 0
}
}
# Dialog to handle colors.
proc htmlColors {} {
global htmluserColors
set this ∞
while {1} {
set colors [lsort [array names htmluserColors]]
set box "-t {Colors:} 10 10 80 30 \
-t Number: 10 50 80 70 \
-b Done 10 100 75 120 -b New 90 100 155 120 -b {New by number} 250 10 370 30"
if {[llength $colors]} {
append box " -m [list [concat [list $this] $colors]] 90 10 230 30"
append box " -b Change 170 100 235 120 -b Remove 250 100 315 120 \
-b {Change number} 250 40 370 60 -b View 250 70 315 90"
foreach c $colors {
lappend box -n $c -t $htmluserColors($c) 90 50 160 90
}
} else {
append box " -m {{None defined} {None defined}} 90 10 230 30"
}
set values [eval [concat dialog -w 380 -h 130 $box]]
set this [lindex $values 3]
if {[lindex $values 0]} {
return
} elseif {[lindex $values 1]} {
set newc [htmlAddNewColor]
if {[string length $newc]} {set this $newc}
} elseif {[lindex $values 2]} {
set newc [htmlNameColor "" "Color saved." "" ""]
if {[string length $newc]} {set this $newc}
} elseif {[lindex $values 4]} {
set newcolor [eval [concat colorTriple [list $this] [htmlHexColor $htmluserColors($this)]]]
if {![string length $newcolor]} {continue}
set newc [htmlNameColor [htmlColorHex $newcolor] "Color changed." $this $htmluserColors($this)]
if {[string length $newc]} {set this $newc}
} elseif {[lindex $values 5]} {
if {[askyesno "Remove $this?"] == "yes"} {
htmlColordelete $this $htmluserColors($this)
message "Color removed."
}
} elseif {[lindex $values 6]} {
set newc [htmlNameColor "" "Color changed." $this $htmluserColors($this)]
if {[string length $newc]} {set this $newc}
} else {
eval [concat colorTriple [list $this] [htmlHexColor $htmluserColors($this)]]
}
}
}
# Checks if colornumber is identical to another colour.
proc htmlColorIdentical {colornumber changeColor} {
global htmlColorNumber htmluserColorname
if {( ![catch {set colTest $htmlColorNumber($colornumber)}] || \
![catch {set colTest $htmluserColorname($colornumber)}] ) && \
$colTest != $changeColor} {
alertnote "This color is identical with '$colTest'. Two identical \
colors cannot be defined."
return 1
}
return 0
}
# Converts a red green blue number to hex.
proc htmlColorHex {color} {
set hexa {A B C D E F}
set red [expr round([lindex $color 0] / 256.0)]
set green [expr round([lindex $color 1] / 256.0)]
set blue [expr round([lindex $color 2] / 256.0)]
set cols [list [expr $red / 16] [expr $red % 16] [expr $green / 16] [expr $green % 16] [expr $blue / 16] [expr $blue % 16]]
set colornumber {#}
foreach c $cols {
if {$c > 9} {
set c1 [lindex $hexa [expr $c - 10]]
} else {
set c1 $c
}
append colornumber $c1
}
return $colornumber
}
# Converts a hex number to red green blue.
proc htmlHexColor {number} {
foreach c [split [string range $number 1 end] ""] {
switch $c {
A {set c1 10}
B {set c1 11}
C {set c1 12}
D {set c1 13}
E {set c1 14}
F {set c1 15}
default {set c1 $c}
}
lappend numbers $c1
}
set red [expr [lindex $numbers 0] * 4096 + [lindex $numbers 1] * 256]
set green [expr [lindex $numbers 2] * 4096 + [lindex $numbers 3] * 256]
set blue [expr [lindex $numbers 4] * 4096 + [lindex $numbers 5] * 256]
return [list $red $green $blue]
}
proc htmlAddNewColor {} {
set newcolor [colorTriple "New color"]
if {![string length $newcolor]} {return }
return [htmlNameColor [htmlColorHex $newcolor] "Color saved." "" ""]
}
proc htmlNameColor {colornumber msg changeColor changeNumber} {
global htmluserColors basicColors
set alluserColors [array names htmluserColors]
set noname 1
set picker [string length $colornumber]
set values [list $changeColor $changeNumber]
while {$noname} {
if {!$picker} {
if {[string length $changeColor]} {
set ttt Change
} else {
set ttt New
}
set values [dialog -w 300 -h 150 -t "$ttt color" 50 10 250 30 \
-t "Name:" 10 45 75 65 -e [lindex $values 0] 80 45 290 60 \
-t "Number:" 10 75 75 95 -e [lindex $values 1] 80 75 150 90 \
-b OK 20 120 85 140 -b Cancel 110 120 175 140]
if {[lindex $values 3]} {return}
set colorname [string trim [lindex $values 0]]
set colornumber [string trim [lindex $values 1]]
set coltest [htmlCheckColorNumber $colornumber]
if {$coltest == "0"} {
alertnote "$colornumber is not a valid color number. It should be of the form #RRBBGG."
continue
}
set colornumber $coltest
if {[htmlColorIdentical $colornumber $changeColor]} {return}
} else {
if {[htmlColorIdentical $colornumber $changeColor]} {return}
if {[catch {prompt "Color name" $changeColor} colorname]} {
# cancel
return
}
set colorname [string trim $colorname]
}
if {[lsearch -exact $basicColors $colorname] >= 0} {
alertnote "Predefined color. Choose another name."
} elseif {[string length $colorname]} {
set replace 0
if {[lsearch -exact $alluserColors $colorname] >= 0 && \
$colorname != $changeColor} {
set repl [dialog -w 200 -h 75 -b Cancel 20 40 80 60 \
-b Replace 115 40 175 60 \
-t "Replace $colorname?" 10 10 150 30]
if {[lindex $repl 1] } {
set replace 1
# remove the color first
set oldnumber $htmluserColors($colorname)
htmlColordelete $colorname $oldnumber
}
} else {
set replace 1
}
# add the new color
if {$replace} {
if {[string length $changeColor]} {
htmlColordelete $changeColor $changeNumber
}
set noname 0
htmlColordef $colorname $colornumber
message $msg
}
} else {
alertnote "You must name the color."
}
}
return $colorname
}
proc htmlColordef {colorname colornumber} {
global htmluserColors htmluserColorname
set htmluserColors($colorname) $colornumber
set htmluserColorname($colornumber) $colorname
addArrDef htmluserColors $colorname $colornumber
addArrDef htmluserColorname $colornumber $colorname
}
proc htmlColordelete {colorname colornumber} {
global htmluserColors htmluserColorname
catch {unset htmluserColors($colorname)}
catch {unset htmluserColorname($colornumber)}
removeArrDef htmluserColors $colorname
removeArrDef htmluserColorname $colornumber
}
#===============================================================================
# Home pages
#===============================================================================
# Dialog to handle servers and corresponding home page folders.
proc htmlHomePages {{this ""}} {
global modifiedModeVars HTMLmodeVars
set pages $HTMLmodeVars(homePages)
set touchedIt 0
if {$this == ""} {set this ∞}
while {1} {
set box "-t {Home pages} 180 10 300 30 -t {Server URLs:} 10 40 100 60 \
-t {Home Page Folder:} 10 70 110 110 \
-t {Include Folder:} 10 120 110 140 -t {Default file:} 12 170 100 190 \
-b OK 10 200 75 220 -b Cancel 90 200 155 220 -b New 170 200 235 220\
-c {Tell Big Brother} 0 320 170 440 190"
if {[llength $pages]} {
set pgs ""
foreach pg $pages {
lappend pgs "[lindex $pg 1][lindex $pg 2]"
}
append box " -m [list [concat $this $pgs]] 110 40 440 60"
append box " -b Change 250 200 315 220 -b Remove 330 200 395 220"
foreach pg $pages {
lappend box -n "[lindex $pg 1][lindex $pg 2]" -t [lindex $pg 0] 120 70 440 110 \
-t [lindex $pg 3] 110 170 310 190
if {[llength $pg] == 5} {lappend box -t [lindex $pg 4] 120 120 440 160}
}
} else {
append box " -m {{None defined} {None defined}} 110 40 440 60"
}
set values [eval [concat dialog -w 450 -h 230 $box]]
set this [lindex $values 4]
if {[lindex $values 0]} {
set HTMLmodeVars(homePages) $pages
lappend modifiedModeVars {homePages HTMLmodeVars}
if {[lindex $values 3] && [askyesno "Change URL mappings in Big Brother?"] == "yes"} {
if {[catch {file tail [launchBackAppl Bbth]} name]} {
alertnote "Could not find or launch Big Brother."
return
}
set allSettings [AEBuild -r $name core getd ---- "obj{want:type('reco'),from:null(),form:'prop',seld:type('allS')}"]
if {[regexp {mapS:} $allSettings]} {
set urlmap [htmlURLmap]
AEBuild $name core setd "----" "obj{want:type('mapG'),from:null(),form:'prop',seld:type('mapS')}" "data" "\[$urlmap\]"
} else {
alertnote "Cannot change the settings in Big Brother. You need Big Brother 1.1 or later."
}
}
return
} elseif {[lindex $values 1]} {
if {!$touchedIt || [askyesno "Really cancel without saving changes?"] == "yes"} {return}
} elseif {[lindex $values 2]} {
set newpg {{} {} {} "index.html" {}}
while {1} {
if {[catch {htmlSetHomePages $pages [lindex $newpg 0] "[lindex $newpg 1][lindex $newpg 2]" [lindex $newpg 3] [lindex $newpg 4]} newpg]} {break}
if {[htmlTestHomePage $pages $newpg]} {
lappend pages $newpg
set this "[lindex $newpg 1][lindex $newpg 2]"
set touchedIt 1
break
}
}
} else {
for {set i 0} {$i < [llength $pages]} {incr i} {
if {"[lindex [lindex $pages $i] 1][lindex [lindex $pages $i] 2]" == $this} {
if {[lindex $values 5]} {
set newpg [lindex $pages $i]
set pg "[lindex $newpg 1][lindex $newpg 2]"
while {1} {
if {[catch {htmlSetHomePages $pages [lindex $newpg 0] "[lindex $newpg 1][lindex $newpg 2]" [lindex $newpg 3] [lindex $newpg 4] $pg} newpg]} {break}
if {[htmlTestHomePage $pages $newpg $pg]} {
set pages [lreplace $pages $i $i $newpg]
set this "[lindex $newpg 1][lindex $newpg 2]"
set touchedIt 1
break
}
}
} else {
set pages [lreplace $pages $i $i]
set touchedIt 1
}
}
}
}
}
}
# Dialog to define or change a home page.
proc htmlSetHomePages {pages folder url defFile inclFld {pg ""}} {
while {1} {
set val [dialog -w 450 -h 205 -t "Home Page Folder:" 10 10 135 30 -t $folder 140 10 440 50 \
-t "Include Folder:" 10 60 110 80 -t $inclFld 130 60 440 100 \
-t "Server URL:" 10 110 90 130 \
-e $url 100 110 440 125 -t "Default file:" 10 145 90 160 \
-e $defFile 100 145 440 160 -b OK 20 175 85 195 -b Cancel 110 175 175 195 \
-b "Set…" 20 30 80 50 -b "Set…" 10 80 60 100 -b "Unset" 70 80 120 100]
set url [string trim [lindex $val 0]]
set defFile [string trim [lindex $val 1]]
if {[lindex $val 4] && ![catch {htmlGetAhpFolder "Home Page Folder:" $pages $pg} fld]} {
set folder $fld
} elseif {[lindex $val 5] && ![catch {htmlGetAhpFolder "Include Folder:" $pages $pg} fld]} {
set inclFld $fld
} elseif {[lindex $val 6]} {
set inclFld ""
} elseif {[lindex $val 2]} {
if {![regexp {://} $url]} {
alertnote "The server URL can't be a relative URL."
} elseif {[string length $folder] && [string length $url] && [string length $defFile]} {
regexp -indices {://} $url css
set sl [string first / [string range $url [expr [lindex $css 1] + 1] end]]
if {$sl < 0} {
set base "$url/"
set path ""
} elseif {[string index $url [expr [string length $url] -1]] != "/"} {
alertnote "A directory URL ending with a slash expected."
continue
} else {
set base [string range $url 0 [expr [lindex $css 1] + $sl + 1]]
set path [string range $url [expr [lindex $css 1] + $sl + 2] end]
}
set ret [list $folder $base $path $defFile]
if {$inclFld != ""} {lappend ret $inclFld}
return $ret
} else {
alertnote "Everything must be specified except the include folder."
}
} elseif {[lindex $val 3]} {
error ""
}
}
}
proc htmlTestHomePage {pages newpg {pg ""}} {
foreach p $pages {
if {"[lindex $p 1][lindex $p 2]" == $pg} {continue}
if {[string match "[lindex $p 1][lindex $p 2]*" "[lindex $newpg 1][lindex $newpg 2]"] ||
[string match "[lindex $newpg 1][lindex $newpg 2]*" "[lindex $p 1][lindex $p 2]"]} {
alertnote "There is already a home page folder for [lindex $p 1][lindex $p 2].\
It overlaps with this one."
return 0
}
}
return 1
}
proc htmlGetAhpFolder {txt pages pg} {
set fld [htmlGetDir $txt]
set msg {"home page" "" "" "" include}
foreach p $pages {
foreach i {0 4} {
if {"[lindex $p 1][lindex $p 2]" == $pg && [regexp -nocase [lindex $msg $i] $txt]
|| [llength $p] == $i} {continue}
if {[string match "[lindex $p $i]:*" "$fld:"] || [string match "$fld:*" "[lindex $p $i]:"]} {
alertnote "This folder overlaps with the [lindex $msg $i] folder for [lindex $p 1][lindex $p 2]."
error ""
}
}
}
return $fld
}
#===============================================================================
# Footers
#===============================================================================
proc htmlFooters {} {
global HTMLmodeVars modifiedModeVars
set footers [lsort $HTMLmodeVars(footers)]
set touchedIt 0
set this ∞
while {1} {
set box "-t {Footers:} 10 10 80 30 \
-t Path: 30 50 80 70 \
-b OK 10 110 75 130 -b Cancel 90 110 155 130 -b New 170 110 235 130"
if {[llength $footers]} {
set foot ""
foreach f $footers {
lappend foot [file tail $f]
}
append box " -m [list [concat [list $this] $foot]] 90 10 440 30"
append box " -b Remove 250 110 315 130 -b Insert 330 110 395 130"
foreach f $footers {
lappend box -n [file tail $f] -t $f 90 50 440 90
}
} else {
append box " -m {{None defined} {None defined}} 90 10 440 30"
}
set values [eval [concat dialog -w 450 -h 140 $box]]
set this [lindex $values 3]
if {[lindex $values 0]} {
set HTMLmodeVars(footers) $footers
lappend modifiedModeVars {footers HTMLmodeVars}
return
} elseif {[lindex $values 1]} {
if {!$touchedIt || [askyesno "Really cancel without saving changes?"] == "yes"} {return}
} elseif {[lindex $values 2]} {
if {![catch {htmlNewFooter $footers} newfoot]} {
lappend footers $newfoot
set footers [lsort $footers]
set this [file tail $newfoot]
set touchedIt 1
}
} else {
set i [lsearch -exact $foot $this]
set footerFile [lindex $footers $i]
if {[lindex $values 5]} {
if {![catch {readFile $footerFile} footText]} {
insertText "\r$footText\r"
set HTMLmodeVars(footers) $footers
lappend modifiedModeVars {footers HTMLmodeVars}
message "$this inserted."
return
} else {
alertnote "Could not read $this."
}
} else {
set footers [lreplace $footers $i $i]
set touchedIt 1
}
}
}
}
# Define a file as a footer.
proc htmlNewFooter {footers} {
set newFooter [getfile "Select the file with the footer."]
if {![htmlIsTextFile $newFooter alertnote]} {
error ""
} elseif {[lsearch -exact $footers $newFooter] < 0} {
# Can't define two footers with the same file name.
foreach f $footers {
if {[file tail $f] == [file tail $newFooter]} {
alertnote "There is already a footer with the filename\
'[file tail $newFooter]'. Two footers with the same filename\
cannot be defined."
error ""
}
}
return $newFooter
} else {
alertnote "'[file tail $newFooter]' already a footer."
error ""
}
}
#===============================================================================
# Last modified
#===============================================================================
proc htmlInsertLastMod {} {
set values [dialog -w 300 -h 190 -t "Last modified tags" 40 10 200 30 \
-e "Last modified" 10 40 290 55 -t "Date format" 10 70 100 90 \
-r "Long" 1 10 95 70 115 -r "Abbreviated" 0 80 95 180 115 -r "Short" 0 190 95 250 115 \
-c "Include weekday" 0 10 120 150 140 -c "Include time" 0 160 120 290 140 \
-b OK 20 160 85 180 -b Cancel 110 160 175 180]
if {[lindex $values 7]} {return}
set lm [htmlQuote [lindex $values 0]]
set text "<!-- [htmlSetCase "#LASTMODIFIED TEXT"]=\"$lm\" [htmlSetCase FORM]=\""
if {[lindex $values 1]} {append text [htmlSetCase LONG]}
if {[lindex $values 2]} {append text [htmlSetCase ABBREV]}
if {[lindex $values 3]} {append text [htmlSetCase SHORT]}
if {[lindex $values 4]} {append text [htmlSetCase ",WEEKDAY"]}
if {[lindex $values 5]} {append text [htmlSetCase ",TIME"]}
append text "\" -->"
set text "$text\r[htmlGetLastMod $text]\r<!-- [htmlSetCase /#LASTMODIFIED] -->"
if {![catch {search -s -f 1 -r 1 -m 0 -i 1 {<!--[ \t\r]+#LASTMODIFIED[ \t\r]+[^>]+>} 0} res] &&
![catch {search -s -f 1 -r 1 -m 0 -i 1 {<!--[ \t\r]+/#LASTMODIFIED[ \t\r]+[^>]+>} [lindex $res 1]} res2]} {
if {[askyesno "There are already 'last modified' tags in this document. Replace them?"] == "yes"} {
replaceText [lindex $res 0] [lindex $res2 1] $text
}
} else {
insertText [htmlOpenCR 1] $text "\r\r"
}
}
proc htmlLastModified {name} {
if {[lindex [winNames -f] 0] != $name} {bringToFront $name}
if {![catch {search -s -f 1 -r 1 -m 0 -i 1 {<!--[ \t\r]+#LASTMODIFIED[ \t\r]+[^>]+>} 0} res]} {
if {[catch {search -s -f 1 -r 1 -m 0 -i 1 {<!--[ \t\r]+/#LASTMODIFIED[ \t\r]+[^>]+>} [lindex $res 1]} res2]} {
alertnote "The window '[file tail $name]' contains an opening 'last modified' tag without a matching closing tag."
return
}
set str [htmlGetLastMod [getText [lindex $res 0] [expr [lindex $res 1] + 1]]]
if {$str == "0"} {
alertnote "The window '[file tail $name]' contains invalid 'last modified' tags."
} else {
replaceText [lindex $res 1] [lindex $res2 0] "\r" $str "\r"
}
}
}
proc htmlGetLastMod {str} {
global htmlSpecialCharacter htmlSpecialCapCharacter
set text ""
set form ""
set type ""
if {![regexp -nocase {TEXT=\"([^\"]*)\"} $str dum text] ||
![regexp -nocase {FORM=\"([^\"]*)\"} $str dum form] || $form == "" ||
![regexp -nocase {[^,]*} $form type] ||
[lsearch -exact [list LONG ABBREV SHORT] [string toupper $type]] < 0} {return 0}
set text [htmlUnQuote $text]
set day [string match "*WEEKDAY*" [string toupper $form]]
set tid [string match "*TIME*" [string toupper $form]]
set date [mtime [now] [string tolower $type]]
if {!$day && [string toupper $type] != "SHORT"} {
set date [lreplace $date 0 0 [lrange [lindex $date 0] 1 end]]
}
if {!$tid} {
set date [lindex $date 0]
} else {
set tiden [lindex $date 1]
regexp {^[0-9]+[^0-9]+[0-9]+} $tiden tidstr
set tiden [lreplace $tiden 0 0 $tidstr]
set date [lreplace $date 1 1 $tiden]
}
set text "$text [join $date]"
regsub -all "&" $text "\\&" text
regsub -all "<" $text "\\<" text
regsub -all ">" $text "\\>" text
regsub -all "¿" $text "\\¿" text
regsub -all "¡" $text "\\¡" text
foreach c [array names htmlSpecialCharacter] {
regsub -all $c $text "\\&$htmlSpecialCharacter($c);" text
}
foreach c [array names htmlSpecialCapCharacter] {
regsub -all $c $text "\\&$htmlSpecialCapCharacter($c);" text
}
foreach c [list eth ETH thorn THORN] {
regsub -all "&$c;" $text $c text
}
return $text
}
#===============================================================================
# Includes
#===============================================================================
# Inserts new include tags at the current position.
proc htmlNewInclude {} {
set sexpr {<!--[ \t\r\n]+#INCLUDE[ \t\r\n]+[^>]+>}
set eexpr {<!--[ \t\r\n]+/#INCLUDE[ \t\r\n]+[^>]+>}
if {![catch {search -s -f 0 -r 1 -i 1 -m 0 $sexpr [getPos]} res] &&
([catch {search -s -f 0 -r 1 -i 1 -m 0 $eexpr [getPos]} res1]
|| [lindex $res 0] > [lindex $res1 0])} {
alertnote "Current position is inside an include container."
return
}
if {![catch {search -s -f 1 -r 1 -i 1 -m 0 $eexpr [getPos]} res] &&
([catch {search -s -f 1 -r 1 -i 1 -m 0 $sexpr [getPos]} res1]
|| [lindex $res 0] < [lindex $res1 0])} {
alertnote "Current position is inside an include container."
return
}
if {[catch {getfile "Select file to include."} fil]} {return}
if {![htmlIsTextFile $fil alertnote]} {return}
set fil1 [htmlQuote $fil]
set text "<!-- [htmlSetCase {#INCLUDE FILE=}]\"$fil1\" -->\r\r"
if {![catch {readFile $fil} intext]} {
regsub -all "\n\r" $intext "\r" intext
# Remove include tags from inserted text
regsub -all -nocase $sexpr $intext "" intext
regsub -all -nocase $eexpr $intext "" intext
append text $intext
}
append text "\r\r" "<!-- [htmlSetCase /#INCLUDE] -->"
insertText [htmlOpenCR 1] $text "\r\r"
}
# Updates the text between all include tags.
proc htmlUpdateInclude {where} {
global HTMLmodeVars winModes
global tileLeft tileTop tileWidth errorHeight
set sexpr {<!--[ \t\r\n]+#INCLUDE[ \t\r\n]+[^>]+>}
set eexpr {<!--[ \t\r\n]+/#INCLUDE[ \t\r\n]+[^>]+>}
if {$where == "Window"} {
set wname [lindex [winNames] 0]
set pos 0
while {![catch {search -s -f 1 -r 1 -i 1 -m 0 $sexpr $pos} res]} {
set lnum [lindex [posToRowCol [lindex $res 0]] 0]
set ln [expr 5 - [string length $lnum]]
if {[catch {search -s -f 1 -r 1 -i 1 -m 0 $eexpr [lindex $res 1]} res1]} {
append err "Line $lnum:[format "%$ln\s" ""]Opening include tag without a matching end tag."\
"\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t∞$wname\r"
break
}
if {![catch {search -s -f 1 -r 1 -i 1 -m 0 $sexpr [lindex $res 1]} res2]
&& [lindex $res2 0] < [lindex $res1 0]} {
append err "Line $lnum:[format "%$ln\s" ""]Nested include tags."\
"\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t∞$wname\r"
set pos [lindex $res1 1]
continue
}
if {[catch {htmlReadInclude [getText [lindex $res 0] [lindex $res 1]] 1} text]} {
append err "Line $lnum:[format "%$ln\s" ""]$text"\
"\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t∞$wname\r"
set pos [lindex $res1 1]
} else {
replaceText [lindex $res 1] [lindex $res1 0] "\r\r" $text "\r\r"
set pos [expr [lindex $res 1] + [string length $text] + 4]
}
}
} else {
if {[htmlAllSaved "-c {Save all open windows before updating?}"] == "cancel"} {return}
if {$where == "File"} {
if {[catch {getfile "Select file to update."} files]} {return}
if {![htmlIsTextFile $files alertnote]} {return}
set folder [file tail $files]
set files [list $files]
} elseif {$where == "Folder"} {
if {[catch {htmlGetDir "Update folder:"} folder]} {return}
set subFolders [expr ![string compare yes [askyesno "Update files in subfolders?"]]]
if {$subFolders} {
set files [htmlAllHTMLfiles $folder]
} else {
set files [htmlGetHTMLfiles $folder]
}
} else {
if {![htmlIsThereAHomePage] ||
[catch {htmlWhichHomePage "update"} hp]} {return}
set folder [lindex $hp 0]
set files [htmlAllHTMLfiles $folder]
}
foreach f $files {
if {[catch {open $f} fid]} {continue}
message "Updating [file tail $f]…"
set filecont [read $fid]
close $fid
regsub -all "\n\r" $filecont "\r" filecont
if {[regexp {\n} $filecont]} {
set newln "\n"
} else {
set newln "\r"
}
set linenum 1
set newcont ""
set ismod 0
set errf [string range $f [expr [string length $folder] + 1] end]
while {[regexp -nocase -indices $sexpr $filecont res]} {
incr linenum [regsub -all $newln [string range $filecont 0 [lindex $res 0]] {} dummy]
set l [expr 20 - [string length [file tail $f]]]
set ln [expr 5 - [string length $linenum]]
if {![regexp -nocase -indices $eexpr [string range $filecont [lindex $res 1] end] res1]} {
append err [htmlBrwsErr $errf $l $linenum $ln "Opening include tag without a matching end tag." $f]
break
}
set res1 [list [expr [lindex $res 1] + [lindex $res1 0]] [expr [lindex $res 1] + [lindex $res1 1]]]
if {[regexp -nocase -indices $sexpr [string range $filecont [lindex $res 1] end] res2]
&& [expr [lindex $res 1] + [lindex $res2 0]] < [lindex $res1 0]} {
append err [htmlBrwsErr $errf $l $linenum $ln "Nested include tags." $f]
append newcont [string range $filecont 0 [lindex $res1 1]]
set filecont [string range $filecont [expr [lindex $res1 1] + 1] end]
set linenum [expr [regsub -all $newln $newcont {} dummy] + 1]
continue
}
if {[catch {htmlReadInclude [string range $filecont [lindex $res 0] [lindex $res 1]] 0} text]} {
append err [htmlBrwsErr $errf $l $linenum $ln $text $f]
append newcont [string range $filecont 0 [lindex $res1 1]]
set filecont [string range $filecont [expr [lindex $res1 1] + 1] end]
set linenum [expr [regsub -all $newln $newcont {} dummy] + 1]
continue
}
lappend modified $f
if {[string trim $text] != [string trim [string range $filecont [expr [lindex $res 1] + 1] [expr [lindex $res1 0] - 1]]]} {
set ismod 1
}
append newcont [string range $filecont 0 [lindex $res 1]]
append newcont $newln $newln $text $newln $newln
append newcont [string range $filecont [lindex $res1 0] [lindex $res1 1]]
set linenum [expr [regsub -all $newln $newcont {} dummy] + 1]
set filecont [string range $filecont [expr [lindex $res1 1] + 1] end]
}
if {$ismod} {
append newcont $filecont
set linenum 1
if {[regexp -nocase -indices {<!--[ \t\r\n]+#LASTMODIFIED[ \t\r\n]+[^>]+>} $newcont res]} {
incr linenum [regsub -all $newln [string range $newcont 0 [lindex $res 0]] {} dummy]
set l [expr 20 - [string length [file tail $f]]]
set ln [expr 5 - [string length $linenum]]
if {![regexp -nocase -indices {<!--[ \t\r\n]+/#LASTMODIFIED[ \t\r\n]+[^>]+>} [string range $newcont [lindex $res 1] end] res1]} {
append err [htmlBrwsErr $errf $l $linenum $ln "Opening 'last modified' tag without a matching closing tag." $f]
} else {
set res1 [list [expr [lindex $res 1] + [lindex $res1 0]] [expr [lindex $res 1] + [lindex $res1 1]]]
set str [htmlGetLastMod [string range $newcont [lindex $res 0] [lindex $res 1]]]
if {$str == "0"} {
append err [htmlBrwsErr $errf $l $linenum $ln "Invalid 'last modified' tags." $f]
} else {
set newcont "[string range $newcont 0 [lindex $res 1]]\r$str\r[string range $newcont [lindex $res1 0] end]"
}
}
}
if {[catch {open $f w} fid]} {
append err "$errf[format "%$l\s" ""]; Could not write update to file. An error occured.\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t∞$f\r"
} else {
puts -nonewline $fid $newcont
close $fid
}
}
}
}
if {[info exists err]} {
new -n "* Errors *" -g $tileLeft $tileTop $tileWidth $errorHeight
set name [lindex [winNames] 0]
changeMode [set winModes($name) Brws]
insertText "Errors: (<uparrow> and <downarrow> to browse, <return> to go to file)\r\r"
insertText $err
select [nextLineStart [nextLineStart 0]] [nextLineStart [nextLineStart [nextLineStart 0]]]
setWinInfo dirty 0
setWinInfo read-only 1
scrollUpLine; scrollUpLine
} else {
message "$where updated successfully."
}
if {[info exists modified]} {
foreach w [winNames -f] {
if {[lsearch -exact $modified [stripNameCount $w]] >= 0} {
if {[askyesno "Update affected windows?"] == "yes"} {
foreach ww [winNames -f] {
if {[lsearch -exact $modified [stripNameCount $ww]] >= 0} {
bringToFront $ww
revert
}
}
}
if {[info exists err]} {bringToFront $name}
return
}
}
}
}
# Read content of a file to be included.
proc htmlReadInclude {incl nr} {
if {![regexp -nocase {file=\"([^\"]+)\"} $incl dum fil]} {
error "Invalid opening include tag."
}
set fil [htmlUnQuote $fil]
if {![file exists $fil]} {
error "File not found."
}
if {[catch {readFile $fil} text]} {
error "Could not read file."
}
regsub -all "\n\r" $text "\r" text
if {$nr} {regsub -all "\n" $text "\r" text}
# Remove include tags from inserted text
regsub -all -nocase "<!--\[ \t\r\n\]+/?#INCLUDE\[ \t\r\n\]+\[^>\]+>" $text "" text
return $text
}